Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/himetr1r/modmain.bas

BASIC Source File | 1999-08-15 | 7.5 KB | 234 lines

Attribute VB_Name = "modMain"
'----------------------------------------
'- Name: Sam Huggill
'- Email: [e-mail]
'- Web: http://www.vbsquare.com/
'- Company: Lighthouse Internet Solutions
'- Date/Time: 14/08/99 11:29:26
'----------------------------------------
'- Notes:   Contains generic routines for
'           the application
'----------------------------------------

Option Explicit

Private Const EM_FORMATRANGE As Long = WM_USER + 57
Private Const EM_SETTARGETDEVICE As Long = WM_USER + 72
Private Const PHYSICALOFFSETX As Long = 112
Private Const PHYSICALOFFSETY As Long = 113

Private Type CharRange
    cpMin As Long     ' First character of range (0 for start of doc)
    cpMax As Long     ' Last character of range (-1 for end of doc)
End Type

Private Type FormatRange
    hdc As Long       ' Actual DC to draw on
    hdcTarget As Long ' Target DC for determining text formatting
    rc As RECT        ' Region of the DC to draw to (in twips)
    rcPage As RECT    ' Region of the entire DC (page size) (in twips)
    chrg As CharRange ' Range of text to draw (see above declaration)
End Type

Sub WriteError(iErrNum As Integer, sDesc As String, sSource As String, sDate As String, sPath As String)
    '// Writes all errors to err.log
    Dim F As Integer

    F = FreeFile

    Open sPath For Append As #F
    Print #F, "Error Number: " & iErrNum
    Print #F, "Description: " & sDesc
    Print #F, "Source: " & sSource
    Print #F, "Date: " & sDate
    Print #F, ""
    Close #F

End Sub

Sub CentreForm(F As Form)
    '// Generic CentreForm Routine
    On Error GoTo vbErrHand

    F.tOp = (Screen.Height - F.Height) \ 2
    F.left = (Screen.Width - F.Width) \ 2

    Exit Sub

vbErrHand:
    WriteError Err.Number, Err.Description, Err.Source, Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "mMain: sCentreForm"
End Sub

'**********************************************************************
'Parsing string function
'**********************************************************************
Public Function ParseString(ByVal vsString As String, ByVal vsDelimiter As String, ByVal viNumber As Integer)
    'Author: Steve Anderson
    'Created   : 13/08/98
    'Purpose   : Parses out a section from a delimited string

    Dim iFoundat As Integer
    Dim iFoundatold As Integer
    Dim iCurrentSection As Integer
    Dim sText As String

    On Error GoTo vbErrHand

    If Len(vsString) > 0 And InStr(vsString, vsDelimiter) > 0 And viNumber > 0 Then
        iFoundat = 1
        iFoundatold = 1
        Do While InStr(iFoundatold + 1, vsString, vsDelimiter) > 0
            iFoundatold = iFoundat
            iFoundat = InStr(iFoundat + 1, vsString, vsDelimiter)
            iCurrentSection = iCurrentSection + 1
        Loop

        If viNumber > iCurrentSection Then
            Exit Function
        End If
        iFoundat = 1
        iCurrentSection = 0
        Do
            iFoundatold = iFoundat
            iFoundat = InStr(iFoundat + 1, vsString, vsDelimiter)
            If Trim(sText) = "" Then
                sText = mID(vsString, 1, iFoundat - 1)
                iCurrentSection = iCurrentSection + 1
            Else
                If iFoundat > 0 Then
                    sText = mID(vsString, iFoundatold + 1, (iFoundat - 1) - iFoundatold)
                Else
                    sText = mID(vsString, iFoundatold + 1)
                End If
                iCurrentSection = iCurrentSection + 1
            End If
            If iCurrentSection = viNumber Then
                ParseString = sText
                Exit Do
            End If
        Loop
    End If
    ParseString = sText

    Exit Function

vbErrHand:
    WriteError Err.Number, Err.Description, "ParseString", Now, App.Path & "\err.log"
    MsgBox Err.Description, vbCritical + vbOKOnly, "mMain: ParseString"

End Function

Function ChooseColour(hwnd As Long) As Long
    Dim CustomColours() As Byte
    ' Define array for custom colours.
    ReDim CustomColours(0 To 15) As Byte
    ' Resize the array to hold the elements.
    Dim tChooseColour As CHOOSECOLOR
    ' Declare a user-defined variable for the ChooseColour
    ' type structure.
    With tChooseColour
        .hwndOwner = hwnd
        ' Set the handle for the owner of the window.
        .lpCustColors = StrConv(CustomColours, vbUnicode)
        ' Pass the custom colours array after converting
        ' it to Unicode using the StrConv function.
        .flags = 0&
        ' For this sample, we do not need to use this.
        .lStructSize = Len(tChooseColour)
        ' Set the size of the type structure.
    End With
    If ShowColour(tChooseColour) = 0 Then
        ChooseColour = -1
        Exit Function
    End If

    ChooseColour = tChooseColour.rgbResult
End Function

Sub Main()
On Error Resume Next
    '// Extensibilty still to be finished
    Dim blnBefore As Boolean

    blnBefore = GetSetting(ThisApp, "General", "Installed", False)
    If blnBefore = False Then
        WritePrivateProfileString "Add-Ins32", "prjDevBook.Connect", "0", "vbaddin.ini"
        SaveSetting ThisApp, "General", "Installed", "True"
        Shell App.Path & "\prjDLL.exe"
        DoEvents
        MsgBox "The Add-In has been installed. Run this program again to start using it."
        End
    Else
    If App.StartMode = 0 Then frmMain.Show
    End If
    'frmMain.Show
End Sub

Public Sub ClearTree(tvw As TreeView)
    '// Fast Clearing of treeview by Brad Martinez
    '// http://members.aol.com/bmtz/

    Dim lngHwnd As Long
    Dim lngHItem As Long

    lngHwnd = tvw.hwnd

    Do
        lngHItem = SendMessageLong(lngHwnd, TVM_GETNEXTITEM, TVGN_ROOT, &O0)
        If lngHItem > 0 Then
            SendMessageLong lngHwnd, TVM_DELETEITEM, &O0, lngHItem
        Else
            Exit Do
        End If
    Loop
End Sub

Public Function LastDB() As String

    LastDB = GetSetting(ThisApp, "General", "DBPath")

End Function

Function GetSelectedText(VBInstance As VBIDE.VBE) As String
     Dim startLine As Long, startCol As Long
     Dim endLine As Long, endCol As Long
     Dim codeText As String
     Dim cpa As VBIDE.CodePane
     Dim cmo As VBIDE.CodeModule

     On Error Resume Next

     ' get a reference to the active code window and the underlying module
     ' exit if no one is available
     Set cpa = VBInstance.ActiveCodePane
     Set cmo = cpa.CodeModule
     If Err Then Exit Function

     ' get the current selection coordinates
     cpa.GetSelection startLine, startCol, endLine, endCol
     ' exit if no text is highlighted
     If startLine = endLine And startCol = endCol Then Exit Function

     ' get the code text
     If startLine = endLine Then
          ' only one line is partially or fully highlighted
          codeText = mID$(cmo.Lines(startLine, 1), startCol, endCol - startCol)
     Else
          ' the selection spans multiple lines of code
          ' first, get the selection of the first line
          codeText = mID$(cmo.Lines(startLine, 1), startCol) & vbCrLf
          ' then get the lines in the middle, that are fully highlighted
          If startLine + 1 < endLine Then
               codeText = codeText & cmo.Lines(startLine + 1, _
                   endLine - startLine - 1)
          End If
          ' finally, get the highlighted portion of the last line
          codeText = codeText & left$(cmo.Lines(endLine, 1), endCol - 1)
     End If

     GetSelectedText = codeText
End Function